home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Turnbull China Bikeride
/
Turnbull China Bikeride - Disc 2.iso
/
STUTTGART
/
LANG
/
LISP
/
FOOLS
/
!Fl
/
scm
/
init
< prev
next >
Wrap
Text File
|
1991-10-16
|
8KB
|
245 lines
;;; fools' lisp init file
; c[ad]+r
(define caar (lambda (l) (car (car l))))
(define cdar (lambda (l) (cdr (car l))))
(define cadr (lambda (l) (car (cdr l))))
(define cddr (lambda (l) (cdr (cdr l))))
(define caaar (lambda (l) (car (car (car l)))))
(define cdaar (lambda (l) (cdr (car (car l)))))
(define cadar (lambda (l) (car (cdr (car l)))))
(define cddar (lambda (l) (cdr (cdr (car l)))))
(define caadr (lambda (l) (car (car (cdr l)))))
(define cdadr (lambda (l) (cdr (car (cdr l)))))
(define caddr (lambda (l) (car (cdr (cdr l)))))
(define cdddr (lambda (l) (cdr (cdr (cdr l)))))
(define caaaar (lambda (l) (car (car (car (car l))))))
(define cdaaar (lambda (l) (cdr (car (car (car l))))))
(define cadaar (lambda (l) (car (cdr (car (car l))))))
(define cddaar (lambda (l) (cdr (cdr (car (car l))))))
(define caadar (lambda (l) (car (car (cdr (car l))))))
(define cdadar (lambda (l) (cdr (car (cdr (car l))))))
(define caddar (lambda (l) (car (cdr (cdr (car l))))))
(define cdddar (lambda (l) (cdr (cdr (cdr (car l))))))
(define caaadr (lambda (l) (car (car (car (cdr l))))))
(define cdaadr (lambda (l) (cdr (car (car (cdr l))))))
(define cadadr (lambda (l) (car (cdr (car (cdr l))))))
(define cddadr (lambda (l) (cdr (cdr (car (cdr l))))))
(define caaddr (lambda (l) (car (car (cdr (cdr l))))))
(define cdaddr (lambda (l) (cdr (car (cdr (cdr l))))))
(define cadddr (lambda (l) (car (cdr (cdr (cdr l))))))
(define cddddr (lambda (l) (cdr (cdr (cdr (cdr l))))))
(define-macro define
(lambda (sym . body)
(if (pair? sym)
`(define ,(car sym) (lambda ,(cdr sym) ,@body))
`(define ,sym ,@body))))
(define-macro define-macro
(lambda (macro . body)
(if (pair? macro)
`(define-macro ,(car macro) (lambda ,(cdr macro) ,@body))
`(define-macro ,macro ,@body))))
(define (call/cc proc) (call-with-current-continuation proc))
;;; make procedures for built-in constructs
(define call-with-current-continuation call/cc)
(define (apply func args) (apply func args))
(define (reduce fnc lst init)
; apply binary fnc to each element in lst
; (reduce + '(1 2 3) 0) is equivalent to (+ (+ (+ 0 1) 2) 3)
(if (null? lst) init (reduce fnc (cdr lst) (fnc init (car lst)))))
(define reverse
; reverse the top elements of a list (non-destructive)
((lambda ()
(define (reverse-iter lst rev)
(if (null? lst) rev (reverse-iter (cdr lst) (cons (car lst) rev))))
(lambda (lst) (reverse-iter lst '())))))
(define (map fcn lst)
(define (map-iter lst out)
(if (null? lst)
out
(map-iter (cdr lst) (cons (fcn (car lst)) out))))
(reverse (map-iter lst '())))
(define (for-each fcn lst)
(if (null? lst) #t (begin (fcn (car lst)) (for-each fcn (cdr lst)))))
(define-macro (let bindings . body)
; macro to unsugar (let ((binding val) ... ) expr ... )
`((lambda ,(map car bindings) ,@body) ,@(map cadr bindings)))
(define-macro letrec
; macro to unsugar (letrec ((rec-def val) ... ) expr ... )
((lambda ()
(define (letrec-defs def)
`(define ,(car def) ,@(cdr def)))
(lambda (defs . exprs)
`((lambda () ,@(map letrec-defs defs) ,@exprs))))))
(define-macro (cond . clauses)
(if (null? clauses)
#f
(let ((test (caar clauses)) (exprs (cdar clauses)))
(if (null? exprs)
(if (eq? test 'else)
#t
`(or ,test (cond ,@(cdr clauses))))
(if (eq? test 'else)
`(begin ,@exprs)
(if (and (pair? exprs) (eq? (car exprs) '=>))
(let ((result (string->uninterned-symbol "result")))
`(let ((,result ,test))
(if ,result
(,(cadr exprs) ,result)
(cond ,@(cdr clauses)))))
`(if ,test
(begin ,@exprs)
(cond ,@(cdr clauses)))))))))
(define (atom? x) (not (pair? x)))
(define (1- x) (- x 1))
(define (1+ x) (+ x 1))
(define (negative? a) (< a 0))
(define (positive? a) (> a 0))
(define (zero? a) (= a 0))
(define (even? x) (= x (* 2 (floor (/ x 2)))))
(define (odd? x) (not (= x (* 2 (floor (/ x 2))))))
(define (complex? x) #f)
(define (rational? x) #f)
(define real? number?)
(define (sqrt x) (expt x 0.5))
(define (square x) (* x x))
(define (modulo x y)
(let ((r (remainder x y)))
(if (negative? y)
(if (negative? r) r (+ r y))
(if (negative? r) (+ r y) r))))
(define gcd
(letrec ((gcd-pos
(lambda (u v)
(if (= v 0) u
(gcd-pos v (remainder u v))))))
(lambda args
(reduce gcd-pos (map abs args) 0))))
(define lcm
(letrec ((lcm-2
(lambda (u v)
(number->integer (* (/ u (gcd u v)) v)))))
(lambda args (reduce lcm-2 (map abs args) 1))))
(define (truncate x)
(if (negative? x) (ceil x) (floor x)))
(define (nth n l)
; nth item in list or #f if l is too short
(and (pair? l) (if (<= n 0) (car l) (nth (- n 1) (cdr l)))))
(define length
(letrec ((length-iter
(lambda (lst len)
(if (null? lst) len (length-iter (cdr lst) (+ len 1))))))
(lambda (lst) (length-iter lst 0))))
; t if l terminates with a nil in the last cdr (may not return)
;(define (list? l)
; (if (pair? l) (list? (cdr l)) (null? l)))
; returns #f if l is circular
(define list?
(letrec ((list-iter?
(lambda (l)
(if (pair? l) (list-iter? (cdr l)) (null? l)))))
(lambda (l) (if (cycle? l) #f (list-iter? l)))))
(define (memq item lst)
(if (null? lst) #f (if (eq? item (car lst)) lst (memq item (cdr lst)))))
(define (memv item lst)
(if (null? lst) #f (if (eqv? item (car lst)) lst (memv item (cdr lst)))))
(define (member item lst)
(if (null? lst) () (if (equal? item (car lst)) lst (member item (cdr lst)))))
(define (assq item table)
(if (null? table) #f
(if (eq? item (caar table)) (car table) (assq item (cdr table)))))
(define (assv item table)
(if (null? table) #f
(if (eqv? item (caar table)) (car table) (assv item (cdr table)))))
(define (assoc item table)
(if (null? table) #f
(if (equal? item (caar table)) (car table) (assoc item (cdr table)))))
(define (filter pred lst)
; return a list of the items in lst satisfying pred
(define (filter-iter lst res)
(cond ((null? lst) res)
((pred (car lst)) (filter-iter (cdr lst) (cons (car lst) res)))
(else (filter-iter (cdr lst) res))))
(reverse (filter-iter lst '())))
(define (equal? a b)
; #t if the elements of a and b are recursively equal?
(or (eqv? a b)
(and (pair? a) (pair? b)
(equal? (car a) (car b))
(equal? (cdr a) (cdr b)))
(and (vector? a) (vector? b)
(equal? (vector->list a) (vector->list b)))
(and (box? a) (box? b)
(equal? (unbox a) (unbox b)))))
(define min
; return the minimum of a list of numbers
(letrec ((min2 (lambda (a b) (if (< a b) a b))))
(lambda (first . rest) (reduce min2 rest first))))
(define max
; return the maximum of a list of numbers
(letrec ((max2 (lambda (a b) (if (> a b) a b))))
(lambda (first . rest) (reduce max2 rest first))))
(define (newline . file)
(write-char #\newline (if (null? file) *stdout* (car file))))
(define string=? eqv?)
(define char=? =)
(define char<? <)
(define char>? >)
(define char<=? <=)
(define char>=? >=)
;;; ports
;;; note: input and output ports are not separate types
(define (open-input-file file) (file-open file "r"))
(define (open-output-file file) (file-open file "w"))
(define close-input-port file-close)
(define close-output-port file-close)
(define (current-input-port) *stdin*)
(define (current-output-port) *stdout*)
(define (input-port? file) (eq? (object-type file) 'file))
(define output-port? input-port?)
(define (call-with-input-file filename proc)
(let ((file (open-input-file filename)))
(begin1 (proc file) (close-input-port file))))
(define (call-with-output-file filename proc)
(let ((file (open-output-file filename)))
(begin1 (proc file) (close-output-port file))))
(define (peek-char port)
(let ((char (read-char port)))
(if (not (eof-object? char))
; unread only if not EOF
(unread-char char port))
char))
;;; tracing functions
;;; note: tail recursive calls do not have traceable exits
(define (trace proc) (trace-entry (trace-exit proc)))
(define (untrace proc) (untrace-entry (untrace-exit proc)))
(define (trace-all . procs) (for-each trace procs))
(define (untrace-all . procs) (for-each untrace procs))